home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / TCP-based EVAL server / eval-server.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  2.2 KB  |  78 lines  |  [TEXT/CCL2]
  1. ;;;;Eval-server.lisp
  2. (in-package :ccl)
  3. (defparameter *server-stream-plist* nil)
  4.  
  5. (require "mactcp")
  6.  
  7. ;in order not to get the error
  8.  
  9. (defun  %tcp-control (pb code &optional ignore-error-p ignore-timeout)
  10.   (setf (rref pb tcpioPB.csCode) code
  11.         (rref pb tcpioPB.ioCompletion) (%null-ptr))
  12.   (let* ((err nil))
  13.     (progn
  14.       (loop
  15.         (when (eql (setq err (#_control :async pb)) 0)
  16.           (unless (eql code $TCPPassiveOpen)
  17.             (let* ((*interrupt-level* 0))
  18.               (while (> (setq err (rref pb tcpioPB.ioResult)) 0))))
  19.           )
  20.         (return))
  21.       (unless (or ignore-error-p (eql err 0)
  22.                   (and ignore-timeout (eql err $TCPTimeout)))
  23.         (%tcp-err-disp err))
  24.       err))
  25.   )
  26.  
  27. (defun install-eval-handler-for-tcp-stream (stream &optional (name :eval-handler-for-tcp-stream))
  28.   (%install-periodic-task 
  29.     name
  30.    #'(lambda()
  31.        (when (eql :ESTABLISHED (tcp-state-name (tcp-connection-state stream)))
  32.          (do-eval stream)
  33.          ))
  34.    100)
  35.   )
  36.  
  37. (defun do-eval (server-stream)
  38.   (when (listen server-stream)
  39.     ;there is something to evaluate
  40.     (let ((eval-string (ccl::telnet-read-line server-stream))
  41.           result)
  42.       (setq result (ignore-errors (eval (read-from-string eval-string))))
  43.       (ccl::telnet-write-line server-stream (format nil "~S" result))
  44.       (values :true result))))
  45.  
  46. (defun start-eval-server (&optional (name :eval-handler-for-tcp-stream))
  47.   (let ((stream (open-tcp-stream  nil 5555
  48.                                   :commandtimeout 300000 ;whatever this number means
  49.                                   )))
  50.     (install-eval-handler-for-tcp-stream stream name)
  51.     (setf (getf *server-stream-plist* name) stream)
  52.     )
  53.   )
  54.  
  55. (defun stop-eval-server (name)
  56.   (ccl::%remove-periodic-task name)
  57.   ;should close the stream too
  58.   (close
  59.    (getf *server-stream-plist* name))
  60.   (remf *server-stream-plist* name)
  61.   )
  62.  
  63. (defun stop-all-eval-servers ()
  64.   (let ((servers nil))
  65.     (do ((s *server-stream-plist* (cddr s)))
  66.         ((endp s))
  67.       (push (first s) servers))
  68.     (dolist (s servers)
  69.       (stop-eval-server s)))
  70.   )
  71.   
  72. #|
  73. (start-eval-server)
  74. (start-eval-server :this-is-the-second-server)
  75. (stop-eval-server :this-is-the-second-server)
  76. (stop-all-eval-servers)
  77.  
  78. |#